home *** CD-ROM | disk | FTP | other *** search
/ PC Open 107 / PC Open 107 CD 1.bin / CD1 / INTERNET / COPIA SITI / Getleft / getleft-setup-notcl.exe / {app} / scripts / Rizo.tcl < prev    next >
Encoding:
Text File  |  2004-06-07  |  10.1 KB  |  298 lines
  1. ##############################################################################
  2. ##############################################################################
  3. #                               Rizo.tcl
  4. ##############################################################################
  5. ##############################################################################
  6. # In this file are implemented the procedures to actually do the downloading
  7. # by executing 'cURL'.
  8. ##############################################################################
  9. ##############################################################################
  10. # Copyright 1999-2004 AndrΘs Garcφa Garcφa  -- fandom@retemail.es
  11. # Distributed under the terms of the GPL v2
  12. ##############################################################################
  13. ##############################################################################
  14. namespace eval Rizo {
  15.  
  16. ##############################################################################
  17. # SetCurlVersion
  18. # Getleft now only works with version 7.9 or newer.
  19. ##############################################################################
  20. proc SetCurlVersion {} {
  21.     global   errorCode
  22.     variable leftIndex
  23.     variable speedIndex
  24.     variable cookieJar
  25.  
  26.     if {[catch {exec curl -V} curlVersion]} {
  27.         if {[lindex $errorCode 1]=="ENOENT"} {
  28.             tk_messageBox -type ok -icon error -title "No curl" \
  29.                 -message "Getleft depends on program\n\tcURL\nPlease check the docs"
  30.             exit
  31.         }
  32.     }
  33.  
  34.     if {![regexp {([0-9]+)(?:\.)([0-9]+)} $curlVersion nada mayor minor]} {
  35.         tk_messageBox -type ok -icon error -title Error                      \
  36.                 -message "Program cURL doesn't work.\nPlease check the docs."
  37.         exit
  38.     }
  39.  
  40.     if {($mayor<7)||($minor<9)} {
  41.         tk_messageBox -title Error -type ok \
  42.                 -message "Your 'cURL' version is too old,\n\
  43.                           please upgrade"
  44.         exit
  45.     }
  46.     set cookieJar [file join $::dirGetleft(conf) cookies.txt]
  47.  
  48.     # I define these indexes here because they have been known to change
  49.     # with cURL versions.
  50.  
  51.     set leftIndex  10
  52.     set speedIndex 11
  53.  
  54.     return
  55. }
  56.  
  57. ################################################################################
  58. # Common
  59. #    This procedure takes care of initializing the state variables and invoke
  60. #    'curl' for all the connection types.
  61. #
  62. # Parameters:
  63. #    type: type of connection:
  64. #           - cab: Headers
  65. #           - dat: The link itself
  66. #    args: args that will be passed to curl
  67. ################################################################################
  68. proc Common {type args} {
  69.     global   getleftOptions getleftState errorCode
  70.     variable curlReport
  71.     variable meta
  72.     variable curlError
  73.     variable errorMessage
  74.     variable cookieJar
  75.     variable pipe
  76.  
  77.     set curlReport(pause)          0
  78.     set curlReport(speed)          0
  79.     set curlReport(stop)           0
  80.     set curlError                  0
  81.     set errorMessage              ""
  82.     set getleftOptions(cancelDown) 0
  83.     set ::errorCode               ""
  84.  
  85.     set newArgs [concat {-A "Mozilla/4.0 (compatible; Getleft 1.1.2)"}      \
  86.                          -b \"$cookieJar\" --connect-timeout 60               \
  87.                          [lindex $args 0]]
  88.                          
  89.     if {$getleftOptions(proxy)==1} {
  90.         if {[regexp -nocase {(http://)} $newArgs]} {
  91.             set proxy $getleftOptions(httpProxy)
  92.         } else {
  93.             set proxy $getleftOptions(ftpProxy)
  94.         }
  95.         if {$getleftOptions(useAuthProxy)} {
  96.             set newArgs [concat                                               \
  97.                     -U $getleftOptions(proxyUser):$getleftOptions(proxyPass)  \
  98.                     $newArgs]
  99.         }
  100.         set curlCmd [concat curl -x $proxy $newArgs]
  101.     } else {
  102.         set curlCmd [concat curl $newArgs]
  103.     }
  104.  
  105.     if {$getleftState(os)!="unix"} {
  106.         set curlCmd [concat $curlCmd --stderr -]
  107.         eval {set pipe [open "| $curlCmd" r]}
  108.     } else {
  109.         eval {set pipe [open "| $curlCmd 2>@ stdout" r]}
  110.     }
  111.     fileevent  $pipe readable [list ::Ventana::Rizo::Lector $type]
  112.     fconfigure $pipe -blocking 0
  113.  
  114.     return
  115. }
  116.  
  117. ###############################################################################
  118. # HeadRequest
  119. #    Asks the server for the Headers of the link
  120. #
  121. # Parameters:
  122. #    link: url to download
  123. #    mother: referer page of the link
  124. ###############################################################################
  125. proc HeadRequest {link mother} {
  126.     variable meta
  127.  
  128.     set meta(content)       ""
  129.     set meta(relocate)      ""
  130.     set meta(charSet)       ""
  131.     set meta(versionServer) ""
  132.     set meta(totalBytes)    -1
  133.  
  134.     regsub -all { } $link {%20} link
  135.     regexp {(.*)(#)} $link nada link
  136.  
  137.     if {$mother!="-"} {
  138.         set args [list -e $mother -I $link]
  139.     } else {
  140.         set args [list -I $link]
  141.     }
  142.     Common cab $args
  143.  
  144.     return
  145. }
  146.  
  147. ###############################################################################
  148. # DataRequest
  149. #    Resumes, server allowing, a download
  150. #
  151. # Parameters:
  152. #    file: full path of the file where the url will be downloaded
  153. #    link: url to download
  154. #    mother: referer page of the url
  155. #    resume: '1' if we have to resume dodwnloading the file, defaults to '0'
  156. ###############################################################################
  157. proc DataRequest {file link mother {resume 0}} {
  158.     variable curlReport
  159.     variable meta
  160.  
  161.     set curlReport(percentage) 0
  162.  
  163.     regsub -all { } $link {%20} link
  164.     regexp {(.*)(#)} $link nada link
  165.     if {$mother!="-"} {
  166.         set refererUrl $mother
  167.         set args [list -e $refererUrl -o $file $link]
  168.     } else {
  169.         set args [list -o $file $link]
  170.     }
  171.  
  172.     if {$resume==1} {
  173.         set args [concat $args -C -]
  174.     }
  175.     if {$meta(versionServer)>=1.1} {
  176.         set args [concat $args --speed-time 300 --speed-limit 30]
  177.     }
  178.     Common dat $args
  179.  
  180.     return
  181. }
  182.  
  183. ###############################################################################
  184. # Lector
  185. #   This procedure controls the downloading, it is invoked anytime there is
  186. #   something to proccess
  187. #
  188. # Parameters:
  189. #   tipo: type of request (HEAD, GET, ...) or 'stopNow' to stop
  190. ###############################################################################
  191. proc Lector {tipo} {
  192.     global errorCode getleftState labelDialogs siteUrl
  193.     variable meta
  194.     variable curlReport
  195.     variable curlError
  196.     variable speedIndex
  197.     variable leftIndex
  198.     variable curlVersion
  199.     variable errorMessage
  200.     variable setCookie
  201.     variable pipe
  202.  
  203.     if {($tipo=="stopNow")||($getleftState(downloading)==0)} {
  204.         set pipePid [pid $pipe]
  205.         if {$getleftState(os)=="win"} {
  206.             winkill::kill $pipePid
  207.         } else {
  208.             catch {exec kill -9 $pipePid} result
  209.         }
  210.         catch {close $pipe}
  211.         return
  212.     }
  213.     set endOfFile [eof $pipe]
  214.     if {($endOfFile) || ($curlReport(stop)==1) || ($curlReport(pause)==1)} {
  215.         if {($endOfFile)} {
  216.             set curlReport(end) 1
  217.         }
  218.         fconfigure $pipe -blocking 1
  219.         if {[catch {close $pipe}]} {
  220.             set curlError [lindex $errorCode 2]
  221.             if {$::DEBUG==1} {
  222.                 if {$curlError!=""} {
  223.                     puts "C≤digo de error: $curlError - $errorCode"
  224.                 } else {
  225.                     tk_messageBox -type ok -icon info -message "errorCurl empty - $errorCode"
  226.                 }
  227.             }
  228.           if {(($curlError==18)&&($tipo=="cab"))||($curlError=="")} {
  229.                 set curlError 0
  230.             }
  231.             if {($curlError==7)||($curlError==6)} {
  232.                 if {![info exists getleftState(noConnect,$siteUrl(www))]} {
  233.                     set getleftState(noConnect,$siteUrl(www)) 0
  234.                 } else {
  235.                     incr getleftState(noConnect,$siteUrl(www))
  236.                 }
  237.             }
  238.         }
  239.         return
  240.     }
  241.     if {[gets $pipe line]>=0} {
  242.         if {[string match $line ""]} return
  243.         if {$::DEBUG==1} {
  244.            if {$tipo=="cab"} {
  245.                 if {![regexp {^\s|^1} $line]} {
  246.                    puts $line
  247.                 }
  248.             }
  249.         }
  250.         if {$tipo=="cab"} {
  251.             if {[regexp -nocase {^(?:HTTP/)([0-9].[0-9])(?: )([0-9]*)(?: )(.*)} \
  252.                     $line nada meta(versionServer) meta(code) meta(error)]} {
  253.                 if {$meta(code)>=400} {
  254.                     set errorMessage $meta(error)
  255.                     catch {error "Server Error" SERVER \
  256.                             "Server \"$meta(error)\" $meta(code)"}
  257.                     return
  258.                 }
  259.             }
  260.             regexp -nocase {^(Server: )(.*)}            $line meta(server)            
  261.             regexp -nocase {^(?:Location: )(.*)}        $line nada meta(relocate)
  262.             regexp -nocase {^(?:Content-Type: )([^;]*)} $line nada meta(content)
  263.             regexp -nocase {^(?:Last-Modified: )(.*)}   $line nada meta(lastModified)
  264.             regexp -nocase {^(?:Content-Length: )(.*)}  $line nada meta(totalBytes)
  265.             regexp -nocase {(?:charset=)(.*)} $line nada meta(charSet)
  266.             if {[regexp -nocase {Set-Cookie} $line]} {
  267.                 Cookies::SaveCookie $line
  268.             }
  269.         } else {
  270.             if {[regexp {[^0-9kM:\.\s]} $line]!=0} return
  271.             set curlReport(speed)  [lindex $line $speedIndex]
  272.  
  273.             if {$curlReport(speed)==""} return
  274.             set curlReport(percentage) [lindex $line 0]
  275.             if {[regexp {k$} $curlReport(speed)]} {
  276.                 set curlReport(speed) $curlReport(speed)/s
  277.             } else {
  278.                 if {![regexp {/} $curlReport(speed)]} {
  279.                     if {($curlReport(speed)>512)} {
  280.                         catch {set curlReport(speed) \
  281.                             "[format "%.2f" [expr {$curlReport(speed)/1024.0}]] k/s"}
  282.                         regsub {\.} $curlReport(speed) $labelDialogs(decimal)\
  283.                                 curlReport(speed)
  284.                     } else {
  285.                         catch {set curlReport(speed) \
  286.                             "[format "%.0f" $curlReport(speed)] bytes/s"}
  287.                     }
  288.                 }
  289.             }
  290.             set curlReport(left) "[lindex $line $leftIndex] \
  291.                     ( $curlReport(speed) )"
  292.         }
  293.     }
  294.     return
  295. }
  296.  
  297. }
  298.